home *** CD-ROM | disk | FTP | other *** search
/ Sound Fx / Sound Fx.iso / Software / UNZIPED / DWSTKW / VB / VB3 / PLAYSTK.BAS < prev    next >
Encoding:
BASIC Source File  |  1996-07-08  |  7.5 KB  |  282 lines
  1. '******************************************************************************
  2. ' File:      playstk.c
  3. ' Version:   1.00
  4. ' Tab stops: every 2 columns
  5. ' Project:   DiamondWare's Sound ToolKit for Windows
  6. ' Copyright: 1996 DiamondWare, Ltd.  All rights reserved.*
  7. ' Written:   95/12/11 by David Alen
  8. ' Purpose:   Contains sample application using the WIN-STK
  9. ' History:   96/03/28 KW & JCL finalized for 1.0
  10. '            96/04/14 JCL finalized for 1.01
  11. '            96/05/13 JCL finalized for 1.1 (no changes)
  12. '            96/05/27 JCL finalized for 1.11 (no changes)
  13. '            96/07/08 JCL finalized for 1.2 (no changes)
  14. '
  15. '*Permission is expressely granted to use this program or any derivitive made
  16. ' from it to registered users of the WIN-STK.
  17. '******************************************************************************
  18.  
  19.  
  20.  
  21. Option Explicit
  22.  
  23. Type OFSTRUCT
  24.     cBytes As String * 1
  25.     fFixedDisk As String * 1
  26.     nErrCode As Integer
  27.     reserved As String * 4
  28.     szPathName As String * 128
  29. End Type
  30.  
  31. Declare Function GlobalAlloc Lib "Kernel" (ByVal wFlags As Integer, ByVal dwBytes As Long) As Integer
  32. Declare Function GlobalFree Lib "Kernel" (ByVal hMem As Integer) As Integer
  33. Declare Function GlobalLock Lib "Kernel" (ByVal hMem As Integer) As Long
  34. Declare Function GlobalUnlock Lib "Kernel" (ByVal hMem As Integer) As Integer
  35.  
  36. Declare Function OpenFile Lib "Kernel" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Integer) As Integer
  37. Declare Function llseek Lib "Kernel" Alias "_llseek" (ByVal hfile As Integer, ByVal lOffset As Long, ByVal iOrigin As Integer) As Long
  38. Declare Function hRead Lib "Kernel" Alias "_hread" (ByVal hfile As Integer, ByVal lOffset As Long, ByVal iSize As Long) As Long
  39. Declare Function lclose Lib "Kernel" Alias "_lclose" (ByVal hfile As Integer) As Integer
  40.  
  41. Global Const OF_READ = &H0
  42.  
  43. Global Const GENERIC_READ = &H80000000
  44. Global Const FILE_SHARE_READ = &H1
  45. Global Const OPEN_EXISTING = 3
  46. Global Const FILE_ATTRIBUTE_NORMAL = &H80
  47. Global Const GMEM_MOVEABLE = &H2
  48. Global Const GMEM_SHARE = &H2000
  49.  
  50. Global Const CD_ACTION_OPEN = 1
  51.  
  52. Global Const dws_NOSUCCESS = 0
  53.  
  54. Type SoundInfo
  55.     FileName As String
  56.     Handle As Long
  57.     UnlockHandle As Integer
  58.     soundnum As Integer
  59.     Rate As Integer
  60. End Type
  61.  
  62. Global t_dws_DR As type_dws_DETECTRESULTS
  63. Global t_dws_ID As type_dws_IDEAL
  64. Global t_dws_DP As type_dws_DPlay
  65. Global t_dws_MP As type_dws_MPlay
  66.  
  67. Global giNumSounds As Integer
  68. Global gtSI() As SoundInfo
  69. Global gPlay As type_dws_DPlay
  70.  
  71. Function dwsLoadWave (psFileName As String) As Integer
  72.     ' This procedure loads the passed WAVE file and
  73.     ' prepares it for use with the WinSTK.  It returns the INDEX of gtSI()
  74.     ' that the wave was loaded into.
  75.  
  76.     On Error GoTo LWE
  77.  
  78.     Dim WaveDwd As Long
  79.     Dim hWaveDwd As Long
  80.     Dim WaveTmp As Long
  81.     Dim hWaveTmp As Long
  82.     Dim iStatus As Integer
  83.     Dim lLen As Long
  84.     Dim lTemp As Long
  85.     Dim hfile As Long
  86.     Dim iLoop As Integer
  87.     Dim iIndex As Integer
  88.     
  89.     Dim iResult As Integer
  90.     
  91.     Dim openbuff As OFSTRUCT
  92.     
  93.     hfile = OpenFile(psFileName, openbuff, OF_READ)
  94.     
  95.     If hfile > 0 Then
  96.     lLen = llseek(hfile, 0&, 2)
  97.  
  98.     hWaveTmp = GlobalAlloc(GMEM_MOVEABLE Or GMEM_SHARE, lLen)
  99.     WaveTmp = GlobalLock(hWaveTmp)
  100.  
  101.     iResult = llseek(hfile, 0&, 0)
  102.     iResult = hRead(hfile, WaveTmp, lLen)
  103.     iResult = lclose(hfile)
  104.     Else
  105.     Exit Function
  106.     End If
  107.     
  108.     If InStr(UCase(psFileName), ".WAV") Then
  109.     '  convert WAV to DWD
  110.     lTemp = lLen
  111.     iStatus = dws_WAV2DWD(ByVal WaveTmp, lTemp, ByVal 0&)
  112.     If iStatus = False Then
  113.         dwsShowError
  114.         Exit Function
  115.     End If
  116.     
  117.     hWaveDwd = GlobalAlloc(GMEM_MOVEABLE, lTemp)
  118.     WaveDwd = GlobalLock(hWaveDwd)
  119.     
  120.     iStatus = dws_WAV2DWD(ByVal WaveTmp, lLen, ByVal WaveDwd)
  121.     
  122.     iResult = GlobalUnlock(hWaveTmp)
  123.     iResult = GlobalFree(hWaveTmp)
  124.     
  125.     If iStatus = False Then
  126.         iResult = GlobalUnlock(hWaveDwd)
  127.         iResult = GlobalFree(hWaveDwd)
  128.         dwsShowError
  129.         Exit Function
  130.     End If
  131.     Else
  132.     hWaveDwd = hWaveTmp
  133.     WaveDwd = WaveTmp
  134.     End If
  135.     
  136.     iIndex = -1
  137.     
  138.     giNumSounds = giNumSounds + 1
  139.     
  140.     ' Find an empty index if exists
  141.     For iLoop = 0 To UBound(gtSI)
  142.     If gtSI(iLoop).Handle = 0 Then
  143.         ' Use this one!
  144.         iIndex = iLoop
  145.         Exit For
  146.     End If
  147.     Next iLoop
  148.     
  149.     If iIndex = -1 Then
  150.     ReDim Preserve gtSI(UBound(gtSI) + 1) As SoundInfo
  151.     iIndex = UBound(gtSI)
  152.     End If
  153.     
  154.     gtSI(iIndex).FileName = psFileName
  155.     gtSI(iIndex).Handle = WaveDwd
  156.     gtSI(iIndex).UnlockHandle = hWaveDwd
  157.  
  158.     iResult = dws_DGetRateFromDWD(ByVal gtSI(iIndex).Handle, gtSI(iIndex).Rate)
  159.     
  160.     dwsLoadWave = iIndex
  161.     
  162. LWER:
  163.     Exit Function
  164.     
  165. LWE:
  166.     dwsLoadWave = -1
  167.     MsgBox "Error '" + Error + "' occurred in DWSTEST:dwsLoadWave!"
  168.     Resume LWER
  169. End Function
  170.  
  171. Function dwsPlayWave (piIndex As Integer) As Integer
  172.     ' This procedure plays a loaded wave by using the passed
  173.     ' memory handle.
  174.  
  175.     Dim tPlay As type_dws_DPlay
  176.     Dim iStatus As Integer
  177.  
  178.     LSet tPlay = gPlay
  179.     
  180.     tPlay.snd = gtSI(piIndex).Handle
  181.     tPlay.Count = 1
  182.     
  183.     tPlay.flags = dws_dplay_SND Or dws_dplay_COUNT Or dws_dplay_LVOL Or dws_dplay_RVOL Or dws_dplay_PITCH
  184.     
  185.     iStatus = dws_DPlay(tPlay)
  186.     
  187.     gtSI(piIndex).soundnum = tPlay.soundnum
  188.     
  189.     If iStatus = 0 Then
  190.     dwsShowError
  191.     Exit Function
  192.     End If
  193.     
  194.     dwsPlayWave = True
  195. End Function
  196.  
  197. Sub dwsShowError ()
  198.     ' An error has occurred!  Show it!
  199.     Dim iError As Integer
  200.     Dim sError As String
  201.     
  202.     iError = dws_ErrNo()
  203.     
  204.     Select Case iError
  205.     Case dws_NOTINITTED
  206.         sError = "Not Initialized"
  207.     Case dws_ALREADYINITTED
  208.         sError = "Already Initialized"
  209.     Case dws_NOTSUPPORTED
  210.         sError = "Not Supported"
  211.     Case dws_INTERNALERROR
  212.         sError = "Internal Error"
  213.     Case dws_INVALIDPOINTER
  214.         sError = "Invalid Pointer"
  215.     Case dws_RESOURCEINUSE
  216.         sError = "Resource In Use"
  217.     Case dws_MEMORYALLOCFAILED
  218.         sError = "Memory Alloc Failed"
  219.     Case dws_SETEVENTFAILED
  220.         sError = "Set Event Failed"
  221.     Case dws_BUSY
  222.         sError = "Busy"
  223.     Case dws_Init_BUFTOOSMALL
  224.         sError = "Buffer Too Small"
  225.     Case dws_D_NOTADWD
  226.         sError = "Not a DWD"
  227.     Case dws_D_NOTSUPPORTEDVER
  228.         sError = "Not Supported Version"
  229.     Case dws_D_BADDPLAY
  230.         sError = "Bad (D) Play"
  231.     Case dws_DPlay_NOSPACEFORSOUND
  232.         sError = "No Space For Sound"
  233.     Case dws_WAV2DWD_NOTAWAVE
  234.         sError = "Not A Wave"
  235.     Case dws_WAV2DWD_UNSUPPORTEDFORMAT
  236.         sError = "Unsupport Format"
  237.     Case dws_M_BADMPLAY
  238.         sError = "Bad (M) Play"
  239.     Case Else
  240.         sError = "<unknown #" + CStr(iError) + ">"
  241.     End Select
  242.     
  243.     MsgBox "Error '" + sError + "' occurred!"
  244. End Sub
  245.  
  246. Function dwsUnloadWave (piIndex As Integer) As Integer
  247.     ' This procedure removes a loaded WAVE file via
  248.     ' the Wave's Index.
  249.     
  250.     Dim iLoop As Integer
  251.     Dim iResult As Integer
  252.  
  253.     On Error GoTo UWE
  254.  
  255.     If giNumSounds = 0 Or piIndex < 0 Or piIndex > (giNumSounds - 1) Then
  256.     Exit Function
  257.     End If
  258.     
  259.     If gtSI(piIndex).Handle <> 0 Then
  260.     ' Free the memory that's holding the wave
  261.     iResult = GlobalUnlock(gtSI(piIndex).UnlockHandle)
  262.     iResult = GlobalFree(gtSI(piIndex).UnlockHandle)
  263.     
  264.     ' Remove the sound Index!
  265.     gtSI(piIndex).Handle = 0
  266.     gtSI(piIndex).UnlockHandle = 0
  267.     gtSI(piIndex).FileName = ""
  268.     
  269.     giNumSounds = giNumSounds - 1
  270.     
  271.     dwsUnloadWave = True
  272.     End If
  273.  
  274. UWER:
  275.     Exit Function
  276.     
  277. UWE:
  278.     MsgBox "Error '" + Error + "' occurred in DWSTEST:dwsUnloadLoadWave!"
  279.     Resume UWER
  280. End Function
  281.  
  282.